home *** CD-ROM | disk | FTP | other *** search
/ Belgian Amiga Club - ADF Collection / BS1 part 68.7z / BS1 part 68 / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).7z / InterChange Plus v3.0 (1993-11)(Syndesis)(Disk 2 of 2).adf / PC_Tools.LZH / ALISP.ZIP / CLRMESH.LSP < prev    next >
Lisp/Scheme  |  1993-10-06  |  3KB  |  74 lines
  1. ;*******************  CLRMESH.LSP  **************************
  2. ;************  WRITTEN BY PATRICK McDONALD  *****************
  3. ;*****************  March 18, 1991  *************************
  4. ;AUTOLISP STUDENT, BILLINGS VOCATIONAL TECHNICAL CENTER
  5. ;CLRMESH will change the colors of 3dfaces depending on their elevation.
  6. ;It is very useful when changing colors in a 3D-Mesh representation
  7. ;of a land surface.
  8. ;It requires a minimum and maximum elevation and if the highest point
  9. ;of the 3DFACE falls within this range than the 3DFACES color will be
  10. ;changed.
  11. ;You may specify the new color by either the color number or the color name.
  12. ;
  13. ;Your comments and suggestions are appreciated.  Compuserve user# 76264,2273
  14.  (defun c:clrmesh ()
  15.    (setq minr (getdist "\nElevation range minimum: ")
  16.          maxr (getdist "\nElevation range maximum: ")
  17.             w 1
  18.    );close setq
  19. (initget "NAme NUmber")
  20. (setq qu (getkword "\nSpecify color by NUmber or <NAme>: "))
  21.   (if (= qu "NUmber")
  22.       (setq clrn (getint "\nColor NUMBER for faces within range: "))
  23.       (while w
  24.        (setq clr (strcase (getstring "\nColor NAME for faces within range: ")))
  25.               (setq clrn (cond ((= clr "RED") 1)
  26.                          ((= clr "YELLOW") 2)
  27.                          ((= clr "GREEN") 3)
  28.                          ((= clr "CYAN") 4)
  29.                          ((= clr "BLUE") 5)
  30.                          ((= clr "MAGENTA") 6)
  31.                          ((= clr "WHITE") 7)
  32.                          ((= clr "GREY") 8)
  33.                          (T nil)
  34.                    );close cond
  35.          );close setq
  36.         (if (= clrn nil) (progn (prompt "\nUnsupported color name...")
  37.         (prompt "\nBlue, Cyan, Green, Grey, Magenta, Red, White, or Yellow...")
  38.                          );close progn      
  39.                          (setq w nil)
  40.         );close if
  41.      );close while/else
  42.    );close if
  43. (initget "Select All")
  44.   (setq ans (getkword "\n[S]elect individual faces <All>: "))
  45.   (if (= ans "Select")
  46.       (setq sst (ssget))
  47.   );close if  
  48.   (if (or (= ans nil) (= ans "All"))
  49.       (setq sst (ssget "x" (list (cons 0 "3DFACE"))))
  50.   );close if
  51.   (setq cnt 0)
  52.     (repeat (sslength sst)
  53.        (setq fac (entget (ssname sst cnt)))
  54.           (if (= (cdr (assoc 0 fac)) "3DFACE")
  55.               (progn
  56.                 (setq c1 (cdr (assoc 10 fac))
  57.                       c2 (cdr (assoc 11 fac))
  58.                       c3 (cdr (assoc 12 fac))
  59.                       c4 (cdr (assoc 13 fac))
  60.                      mxc (max (caddr c1) (caddr c2) (caddr c3) (caddr c4))
  61.                 );close setq
  62.                 (if (and (>= mxc minr) (<= mxc maxr))
  63.                    (if (= (assoc 62 fac) nil)
  64.                        (entmod (setq fac (append fac (list (cons 62 clrn)))))
  65.                        (entmod (subst (cons 62 clrn) (assoc 62 fac) fac))
  66.                    );close if3
  67.                 );close if2
  68.               );close progn
  69.           );close if1
  70.       (setq cnt (1+ cnt))
  71.     );close repeat
  72. );close defun
  73.  
  74.